home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / Supplement / Demo Folder / Turtle < prev   
Text File  |  1991-01-01  |  4KB  |  133 lines
  1. (  Turtle Graphics Objects for Demo )
  2. (  05/05/84  CBD   Version 1.0 )
  3. Decimal
  4.  
  5. \ Define a turtle-graphics pen
  6.  
  7. :CLASS Pen  <Super Object
  8.  
  9.     \ 1st 5 Ivars comprise a PenState structure
  10.     Point   PnLoc       \ location of pen
  11.     Point   PnSize      \ width,  height
  12.     Int     PnMode
  13.     Var     PnPatLo
  14.        Var     PnPatHi
  15.  
  16.     Angle   Direction
  17.        Point   homeLoc 
  18.        Int     maxReps
  19.        Int     initLen
  20.        Int     deltaLen    \ change in len
  21.        Int     deltaDeg    \ change in angle
  22.           
  23.     :M  GET:    (ABS)  call GetPenState  ;M    \ save state here
  24.     :M  SET:    (ABS)  call SetPenState  ;M    \  restore from here
  25.    
  26.     :M  TURN:  +: Direction  Get: Direction  359 > 
  27.                      IF  -360 +: Direction THEN   ;M
  28.  
  29.     :M  NORTH:   0 Put: Direction  ;M
  30.  
  31.     \ ( x y -- )  Draw a line to x,y if pen shows
  32.     :M  MOVETO:  Set: Self   Pack  call LineTo  Get: Self  ;M
  33.  
  34.     \ ( d  -- )   Draw d bits in current direction
  35.     :M  MOVE:   {  Dist -- }
  36.            set: self  Sin: Direction  dist * 10000 /
  37.            Cos: Direction dist  * 10000 /
  38.            Pack call Line  get: self    ;M
  39.        
  40.     \ ( x y -- )  Goto a location without drawing
  41.     :M  GOTO:    Put:  PnLoc     ;M
  42.    
  43.     \ ( x y -- )  set the center coordinates
  44.     :M  CENTER:  put: homeLoc  ;M
  45.    
  46.     \ ( -- )  Place Pen in center of Forth Window
  47.     :M  HOME:   get: homeLoc  Goto: Self   ;M
  48.  
  49.     \ ( w h -- )  Set size in pixels of drawing pen
  50.     :M  SIZE:      Put: PnSize     ;M
  51.  
  52.     \ ( x y w h mode  -- )
  53.     :M  INIT:   Put:  PnMode  Put: PnSize   Put: PnLoc    ;M
  54.  
  55.     \ ( initlen dLen dDeg -- )  set parameters
  56.     :M  PUTRANGE:  put: deltaDeg  put: deltaLen  put: initLen  ;M
  57.  
  58.     \ ( maxReps -- ) 
  59.     :M  PUTMAX:  put: maxReps  ;M
  60.  
  61.     :M  CLASSINIT:   Get: self  home: self  200 put: maxReps ;M
  62.  
  63.     \ Draw a spiral of line segments - Logo POLYSPI
  64.     :M  SPIRAL:  { \ dist  degrees delta   -- }  home: self
  65.             get: initLen -> dist  get: deltaLen -> delta
  66.                get: deltaDeg -> degrees
  67.             BEGIN  dist get: maxReps < 
  68.                WHILE
  69.                    dist Move: Self  degrees  Turn: Self
  70.                    delta ++> dist  
  71.             REPEAT  ;M
  72.  
  73.     \ ( n -- )  Dragon curves from Martin Gardner
  74.     :M  DRAGON:  Dup  0=   
  75.             IF  Get: deltaLen  Move: Self  Drop  
  76.             ELSE  Dup  0 > 
  77.                 IF  Dup 1- Dragon: Self  
  78.                     Get: DeltaDeg Turn: Self
  79.                     1 swap - Dragon: Self 
  80.                 ELSE  -1 over - Dragon: Self
  81.                     360 Get: deltaDeg - turn: Self
  82.                     1+ Dragon: Self 
  83.                 THEN
  84.             THEN  ;M
  85.         
  86.     \ draw an infinite Lissajous figure 
  87.     :M  LJ:  { \ c1 c2 chg  reps -- }   North: self  0 -> reps
  88.         get: initLen -> c1  get: deltaLen -> c2  get: deltaDeg -> chg 
  89.         0 sin 120 / getX: homeLoc + 0 cos 120 / getY: homeLoc +  goto: self 
  90.         BEGIN   1 ++> reps  reps  get: maxReps  <
  91.          WHILE
  92.             c1  Get: direction * sin 120 /  getX: homeLoc +
  93.             c2  Get: direction * cos 120 /  getY: homeLoc + MoveTo: Self
  94.             chg  turn: self    \ allow the user to stop it
  95.         REPEAT  ;M
  96.  
  97. ;CLASS
  98.  
  99. \ Define a Smalltalk Polygon object as subclass of Pen  
  100. :CLASS Poly  <Super Pen
  101.  
  102.     Int     Sides   \ # of sides in the Polygon  
  103.     Int     Length  \ of each side  
  104.  
  105.     :M  DRAW:  Get: Sides  0
  106.         DO   Get:  Length  Move: Self  
  107.             360 Get:  Sides /  Turn: Self
  108.         LOOP ;M
  109.       
  110.     \ ( len  #sides -- )  Store sides and go to Home
  111.     :M  SIZE:  Get: Self  Put: Sides  Put: Length 
  112.         Home:  Self   North: Self  ;M
  113.  
  114.     \ Spin a series of polygons around a point  
  115.     :M  SPIN: { \ reps -- } Home: self  10 Get: InitLen Size: self 
  116.          0 -> reps 
  117.          BEGIN  reps  get: maxReps  < 
  118.          WHILE   Draw:  Self  Get: deltaDeg  Turn: Self
  119.             Get: deltaLen +: Length  1 ++> reps 
  120.          REPEAT  ;M
  121.      
  122.     \ Default Poly is 30-dot triangle
  123.     :M  CLASSINIT:  30 3 Size: self  100 put: maxReps  ;M
  124.  
  125. ;CLASS
  126.  
  127. \ Create a pen named Bic
  128. Pen Bic  
  129.  
  130. \ Create a Polygon name Anna
  131. Poly Anna
  132. 60 4  Size: Anna
  133.